Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/dde2/ddepm.frm

Text File | 1993-05-16 | 8KB | 335 lines

VERSION 2.00
Begin Form Form1
   Caption         =   "Create a Program Group"
   ClientHeight    =   3450
   ClientLeft      =   1125
   ClientTop       =   2385
   ClientWidth     =   8190
   Height          =   4140
   Icon            =   DDEPM.FRX:0000
   Left            =   1065
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   ScaleHeight     =   3450
   ScaleWidth      =   8190
   Top             =   1755
   Width           =   8310
   Begin DriveListBox Drive1
      Height          =   1530
      Left            =   120
      TabIndex        =   1
      Top             =   240
      Width           =   2055
   End
   Begin TextBox Text1
      Height          =   375
      Left            =   2280
      TabIndex        =   6
      Text            =   "*.exe"
      Top             =   240
      Width           =   1215
   End
   Begin TextBox Text2
      Height          =   375
      Left            =   6000
      TabIndex        =   4
      Text            =   "Examples"
      Top             =   240
      Width           =   2055
   End
   Begin DirListBox Dir1
      Height          =   2535
      Left            =   120
      TabIndex        =   2
      Top             =   720
      Width           =   2055
   End
   Begin FileListBox File1
      Height          =   2565
      Left            =   2280
      Pattern         =   "*.exe"
      TabIndex        =   3
      Top             =   720
      Width           =   1215
   End
   Begin CommandButton bAdd
      Caption         =   "&Add >>"
      Enabled         =   0   'False
      Height          =   375
      Left            =   3600
      TabIndex        =   10
      Top             =   720
      Width           =   1215
   End
   Begin ListBox List1
      Height          =   2565
      Left            =   4920
      TabIndex        =   5
      Top             =   720
      Width           =   3135
   End
   Begin CommandButton bIterate
      Caption         =   "&Iterate >>"
      Height          =   375
      Left            =   3600
      TabIndex        =   9
      Top             =   1200
      Width           =   1215
   End
   Begin CommandButton bRemove
      Caption         =   "<< &Remove"
      Enabled         =   0   'False
      Height          =   375
      Left            =   3600
      TabIndex        =   11
      Top             =   1680
      Width           =   1215
   End
   Begin CommandButton bMake
      Caption         =   "&Make Group"
      Enabled         =   0   'False
      Height          =   375
      Left            =   3600
      TabIndex        =   0
      Top             =   2400
      Width           =   1215
   End
   Begin CommandButton bExit
      Caption         =   "&Exit"
      Height          =   375
      Left            =   3600
      TabIndex        =   8
      Top             =   2880
      Width           =   1215
   End
   Begin Label Label1
      Alignment       =   1  'Right Justify
      Caption         =   "Group Name:"
      Height          =   375
      Left            =   4680
      TabIndex        =   7
      Top             =   240
      Width           =   1215
   End
   Begin Menu mFile
      Caption         =   "&File"
      Begin Menu mFileAll
         Caption         =   "&Add All"
         Shortcut        =   ^A
      End
      Begin Menu mFileAbout
         Caption         =   "A&bout..."
      End
      Begin Menu mSep1
      End
      Begin Menu mFileExit
         Caption         =   "E&xit"
      End
   End
End
Option Explicit

Dim Subdir(100) As String

Const DEFAULT = 0        ' 0 - Default
Const HOURGLASS = 11     ' 11 - Hourglass

Const NONE = 0         ' 0 - None
Const LINK_SOURCE = 1    ' 1 - Source (forms only)
Const LINK_AUTOMATIC = 1 ' 1 - Automatic (controls only)
Const LINK_MANUAL = 2    ' 2 - Manual (controls only)
Const LINK_NOTIFY = 3    ' 3 - Notify (controls only)

Sub bAdd_Click ()
    Dim ThePath As String
    Dim TheFile As String
    Dim lcv As Integer
    Dim AlreadyThere As Integer

    If file1.FileName <> "" Then
    ThePath = dir1.Path
    If Right(ThePath, 1) <> "\" Then ThePath = ThePath + "\"
    TheFile = ThePath + file1.FileName
    For lcv = 0 To list1.ListCount - 1
        If list1.List(lcv) = TheFile Then AlreadyThere = -1
    Next lcv
    If Not AlreadyThere Then list1.AddItem TheFile
    bMake.Enabled = True
    Else
    bAdd.Enabled = False
    End If
End Sub

Sub bExit_Click ()
    End
End Sub

Sub bIterate_Click ()
    Dim ThePath As String
    Dim TheNextPath As String
    Dim TheFile As String
    Dim TheLen As Integer
    Dim lcv As Integer, lcv2 As Integer

    Screen.MousePointer = HOURGLASS
    ThePath = dir1.Path
    TheLen = Len(ThePath)

    For lcv = 0 To dir1.ListCount - 1
    TheNextPath = dir1.List(lcv)
    If Left(TheNextPath, TheLen) = ThePath Then
        file1.Path = TheNextPath
        'Append a \ as needed if it's not the root
        If Right$(TheNextPath, 1) <> "\" Then
        TheNextPath = TheNextPath + "\"
        End If
        For lcv2 = 0 To file1.ListCount - 1
        TheFile = TheNextPath + file1.List(lcv2)
        list1.AddItem TheFile
        Next lcv2
    End If
    Next lcv
    file1.Path = dir1.Path
    If list1.ListCount <> 0 Then bMake.Enabled = True
    Screen.MousePointer = DEFAULT
End Sub

Sub bMake_Click ()
    Dim rc As Integer
    Dim lcv As Integer
    On Error Resume Next

    Screen.MousePointer = HOURGLASS

    text1.LinkMode = NONE
    text1.LinkTimeout = 50  '5 seconds
    text1.LinkTopic = "Progman|progman"
    text1.LinkMode = LINK_MANUAL

    text1.LinkExecute "[CreateGroup(" + text2.Text + ")]"
    rc = DoEvents()

    For lcv = 0 To list1.ListCount - 1
    'Debug.Print list1.list(lcv)
    text1.LinkExecute "[AddItem(" + list1.List(lcv) + ")]"
    rc = DoEvents()
    Next lcv


    text1.LinkExecute "[ShowGroup(" + text2.Text + ", 7)]"
    rc = DoEvents()

    text1.LinkMode = NONE
    Screen.MousePointer = DEFAULT
End Sub

Sub bRemove_Click ()
    If list1.ListIndex <> -1 Then
    list1.RemoveItem list1.ListIndex
    If list1.ListCount = 0 Then
        bMake.Enabled = False
    Else
        list1.ListIndex = 0
    End If
    Else
    bRemove.Enabled = False
    End If
End Sub

Sub Dir1_Change ()
    file1.Path = dir1.Path
End Sub

Sub Drive1_Change ()
    Dim ans As Integer

    On Error GoTo driveerror

    dir1.Path = drive1.Drive

    Exit Sub

driveerror:
    If Err = 68 Then
    ans = MsgBox("Drive not ready.", 2 + 48 + 256, "Drive Error")
    Select Case ans
        Case 3 ' abort
        drive1.Drive = Left(dir1.Path, 2)
        Resume
        Case 4 ' retry
        Resume
        Case 5 ' ignore
        Resume Next
    End Select
    Else
    On Error GoTo 0
    Error Err
    End If
End Sub

Sub File1_Click ()
    If file1.FileName <> "" Then
    bAdd.Enabled = True
    Else
    bAdd.Enabled = False
    End If
End Sub

Sub File1_DblClick ()
    bAdd_Click
End Sub

Sub List1_Click ()
    If list1.Text <> "" Then
    bRemove.Enabled = True
    Else
    bRemove.Enabled = False
    End If
End Sub

Sub List1_DblClick ()
    bRemove_Click
End Sub

Sub mFile_Click ()
    If file1.ListCount > 0 Then
    mFileAll.Enabled = True
    Else
    mFileAll.Enabled = False
    End If
End Sub

Sub mFileAbout_Click ()
    Dim TheText As String

    TheText = "This program allows the selection of multiple files," + Chr(13)
    TheText = TheText + "and the specification of a Group Name.  It will then " + Chr(13)
    TheText = TheText + "create a Program Group in the Windows Program Manager, " + Chr(13)
    TheText = TheText + "containing a Program Item for each file selected." + Chr(13) + Chr(13)
    TheText = TheText + "Use the Iterate button to add all the files below the" + Chr(13)
    TheText = TheText + "current sub-directory." + Chr(13) + Chr(13)

    MsgBox TheText, 64, "About Make Group"
End Sub

Sub mFileAll_Click ()
    Dim rc As Integer
    Dim lcv As Integer

    For lcv = 1 To file1.ListCount
    file1.ListIndex =